home *** CD-ROM | disk | FTP | other *** search
- {$A+,B-,D+,E+,F+,I+,L+,N-,O+,R-,S+,V-}
- {$M 16384,0,655360}
-
- UNIT DBPAS;
-
- interface
-
- uses crt,dos,getfield,screenio;
-
- type
- setc = record
- prompt : byte;
- active : byte;
- inactive : byte;
- shadow : byte;
- clear_chr: char;
- EscKey : boolean;
- Clean : boolean;
- Confirm : boolean;
- Bell : boolean;
- UpDn : boolean;
- Wndw : boolean;
- end;
- DB_Header = RECORD (* dBASE file header *)
- DBType : Byte;
- Year : Byte;
- Month : Byte;
- Day : Byte;
- RecCount : LongInt;
- Location : Integer;
- RecordLen : Integer;
- Reserved : Array[1..20] of Char;
- END;
- DB_Field = Record (* DBF field descriptors *)
- FieldName : Array[1..11] of Char;
- FieldType : char;
- FieldAddress : LongInt;
- FieldLen : Byte;
- FieldDec : Byte;
- Reserved : Array[1..14] of Char;
- END;
- DB_GetDes= Record
- Fstr : string;
- Fnum : byte;
- Area : byte;
- END;
- DB_Fld = ^DB_Field;
- DB_HDR = ^DB_Header;
- DBFObj = ^DBF;
- DB_GetD = ^DB_GetDes;
- filename = string[66];
- str8 = string[8];
- str4 = string[4];
- str2 = string[2];
-
- DBF = object
- DBName : FileName;
- DBFile : file;
- maxflds : integer;
- dberr : word;
- DBarea : byte;
- DB_GetF : byte;
- CurrRec : longint;
- _CHGREC : BOOLEAN;
- _FOUND : BOOLEAN;
- _EXACT : BOOLEAN;
- _EOF : BOOLEAN;
- _BOF : BOOLEAN;
- _ONREC : BOOLEAN;
- _OK : Boolean;
- _Confirm: Boolean;
- DBhdr : DB_Header;
- DBFld : array[1..255] of DB_Fld;
- DBRec : array[1..4000] of char;
- DB_FStr : array[1..255] of DB_GetD;
- procedure ListHdr;
- procedure writehdr;
- procedure readhdr;
- procedure writedbc(ch : char);
-
- procedure zap;
- procedure recallall;
- procedure pack;
- procedure recallrec(RecNum : longint);
- procedure deleterec(RecNum : longint);
- procedure FRESHEN;
- procedure CopySto(Fname : string);
-
- function GetFld(Fnum : Byte) : string;
- procedure replfld(Fnum : Byte;FStr : string);
- procedure SayXY(xpos,ypos,fldnum : byte);
- procedure GetXY(xpos,ypos,fldnum : byte;SayStr,Pix : string);
- procedure GotoRec(RecNum : longint);
- procedure appendblank;
-
- function recno : longint;
- function reccount : longint;
- function deleted : boolean;
-
- procedure skip;
- function Continue(fnum : byte;FldStr : string) : boolean;
- function Locate(fnum : byte;FldStr : string) : boolean;
-
- procedure List;
- procedure ListDB;
- procedure DB_Stat;
-
- procedure NewField(FldName : string;Typ : char;Len,Dec : Byte);
- procedure DoBrowseX(Title,BoxDef : string;TopX,TopY,BotX,BotY,Shadow,Border,WindC,Highbar : byte);
- procedure DoBrowse(X,Y : byte);
- end;
-
- procedure pause;
- function ctod(dates : str8) : string;
- function dtoc(dates : str8) : string;
- function Upper(str : string): string;
- function CurrDate : string;
- function StrToNum(Str : String) : integer;
- procedure ReadGet;
- procedure OpenDB(VAR DB : DBFobj;fname : string);
- function CreateDB(VAR DB : DBFobj;fname : string) : boolean;
- procedure CloseDB(VAR DB : DBFobj);
-
-
- var
- Max_GetF : byte;
- SelectDB : array[1..255] of dbfobj;
- Max_DB : byte;
- SetColor : array[1..5] of setc;
-
- implementation
-
- var
- Get_Rd : array[1..255] of byte;
-
- procedure InitVar(VAR DB : DBFobj);
- begin
- DB^.CurrRec := 0;
- DB^.MaxFlds := 0;
- DB^._EXACT := False;
- DB^._eof := False;
- DB^._Bof := False;
- DB^._OnRec := False;
- DB^._FOUND := False;
- DB^._CHGREC := False;
- DB^._Confirm:= False;
- DB^.DB_GetF := 0;
- end;
-
- procedure InitDB(VAR db : DbfObj);
- begin
- New(DB);
- inc(Max_DB);
- InitVar(DB);
- DB^.DBArea := Max_DB;
- SelectDB[Max_DB] := DB;
- end;
-
- procedure DBF.writedbc(ch : char);
- begin
- blockwrite(dbfile,ch,1,dberr);
- end;
-
- function dtoc(dates : str8) : string;
- var
- month : str2;
- day : str2;
- year : str4;
- m,d : byte;
- code : integer;
- begin
- dtoc := ' ';
- if length(dates) = 8 then
- begin
- month := copy(dates,5,2);
- day := copy(dates,7,2);
- year := copy(dates,3,2);
- Val(Month,m,code);
- Val(day ,d,code);
- if (m > 0) and (m < 13) then
- if (d > 0) and (d < 32) then
- dtoc := month+'/'+day+'/'+year;
- end;
- end;
-
- function ctod(dates : str8) : string;
- var
- month : str2;
- day : str2;
- year : str4;
- m,d : byte;
- code : integer;
- begin
- ctod := ' ';
- if length(dates) = 8 then
- begin
- month := copy(dates,1,2);
- day := copy(dates,4,2);
- year := '19' + copy(dates,7,2);
- Val(Month,m,code);
- Val(day ,d,code);
- if (m > 0) and (m < 13) then
- if (d > 0) and (d < 32) then
- ctod := year+month+day;
- end;
- end;
-
- function Upper(str : string) : string;
- var
- count : byte;
- begin
- for count := 1 to length(str) do
- str[count] := UpCase(str[count]);
- Upper := str;
- end;
-
- function CurrDate : string;
- var
- y, m, d, dow : Word;
- ys,ms,ds : string[4];
- begin
- GetDate(y,m,d,dow);
- Str(y,ys);
- Str(m,ms);
- Str(d,ds);
- NumStr(ms,2,0);
- NumStr(ds,2,0);
- NumStr(ys,2,0);
- if m < 10 then ms[1] := '0';
- if d < 10 then ds[1] := '0';
- CurrDate := dtoc(ys+ms+ds);
- end;
-
- function CharToStr(input : array of char) : string;
- var
- count : integer;
- str : string;
- begin
- count := 0;
- str := '';
- repeat
- str := str+input[count];
- inc(count);
- until input[count] = #0;
- CharToStr := str;
- end;
-
- procedure StrToChar(input : string;VAR output : array of char;FChar : char);
- var
- count : integer;
- begin
- fillchar(output,SizeOf(output),FChar);
- for count := 1 to length(input) do
- output[count-1] := input[count];
- end;
-
- procedure dbf.WriteHdr;
- var
- y, m, d, dow : Word;
- count : byte;
- nullc : char;
- reclen : longint;
- begin
- reset(dbfile,1);
- reclen := 1;
- GetDate(y,m,d,dow);
- dow := y;
- dec(dow,50);
- dec(y,round(dow/100)*100);
- for count := 1 to MaxFlds do
- inc(reclen,dbfld[count]^.FieldLen);
- with dbhdr do
- begin
- dbtype := 3;
- year := y;
- month := m;
- day := d;
- location := MaxFlds*32+33;
- recordlen := RecLen;
- if FileSize(DBfile) > location then reccount := round((FileSize(DBfile)-Location)/recordlen)
- else reccount := 0;
- FillChar(reserved,SizeOf(reserved),#0);
- end;
- blockwrite(DBfile,dbhdr,SizeOf(dbhdr),dberr);
- for count := 1 to MaxFlds do
- begin
- if count = 1 then dbfld[count]^.FieldAddress := 1
- else dbfld[count]^.FieldAddress := dbfld[count-1]^.FieldAddress+dbfld[count-1]^.FieldLen;
- blockwrite(DBfile,dbfld[count]^,SizeOf(dbfld[count]^),dberr);
- end;
- if dbhdr.reccount > 0 then writedbc(#13)
- else writedbc(#0);
- end;
-
- procedure CloseDB(VAR DB : DBFobj);
- var
- count : byte;
- begin
- DB^.WriteHdr;
- for count := DB^.MaxFlds downto 1 do
- dispose(DB^.dbfld[count]);
- close(DB^.dbfile);
- end;
-
- procedure dbf.readhdr;
- var
- fnum : byte;
- fpos,sz : longint;
- begin
- reset(dbfile,1);
- blockread(DBfile,dbhdr,SizeOf(dbhdr),dberr);
- for fnum := 1 to MaxFlds do
- Dispose(dbfld[Fnum]);
- MaxFlds := (dbhdr.location-SizeOf(dbhdr)) div SizeOf(DB_Field);
- for fnum := 1 to MaxFlds do
- begin
- New(dbfld[Fnum]);
- blockread(DBfile,dbfld[Fnum]^,SizeOf(dbfld[Fnum]^),dberr);
- end;
- end;
-
- function DBF.deleted : boolean;
- begin
- _CHGREC := True;
- if DBRec[1] = '*' then deleted := TRUE
- else deleted := FALSE;
- end;
-
- procedure DBF.GotoRec(RecNum : longint);
- var
- Fpos : longint;
- begin
- {$I-}
- Seek(DBfile,dbhdr.location+((recnum-1)*dbhdr.recordlen));
- {$I+}
- if IOResult = 0 then
- begin
- _BOF := FALSE;
- _EOF := FALSE;
- _ONREC := TRUE;
- Fpos := FilePos(DBfile);
- blockread(DBfile,DBRec,dbhdr.recordlen,dberr);
- if dberr = dbhdr.recordlen then _FOUND := TRUE else _FOUND := False;
- if _FOUND then CurrRec := RecNum
- else begin
- if RecNum > 0 then _EOF := TRUE else _BOF := TRUE;
- CurrRec := 0;
- end;
- Seek(DBfile,Fpos);
- end else begin
- if RecNum > 0 then _EOF := TRUE else _BOF := TRUE;
- _ONREC := FALSE;
- end;
- end;
-
- procedure DBF.DB_Stat;
- var
- count : byte;
- begin
- clrscr;
- count := 1;
- writeln;
- writeln(' Name Type Address Length Decimals Reserved ');
- writeln('----------- - ------- --- --- --------------');
- for count := 1 to MaxFlds do
- with dbfld[count]^ do
- writeln(fieldname:11,' ',FieldType:1,FieldAddress:11,FieldLen:5,FieldDec:10,Reserved:20);
- writeln;
- with dbhdr do
- begin
- gotoxy(50,6); writeln('Database Statistics');
- gotoxy(50,7); writeln('------------------------------');
- gotoxy(50,8); writeln('Type.......... ',DBType);
- gotoxy(50,9); writeln('Last Update... ',Month,'/',day,'/',year);
- gotoxy(50,10); writeln('Record Length. ',Recordlen);
- gotoxy(50,11); writeln('Records....... ',reccount);
- gotoxy(50,12); writeln('Start Offset.. ',location);
- gotoxy(50,13); writeln('Reserved...... ',reserved);
- end;
- gotoxy(1,24);
- end;
-
- function CreateDB(VAR DB : DBFobj;fname : string) : boolean;
- begin
- InitDB(DB);
- {$I-}
- DB^._CHGREC := True;
- Assign(DB^.DBfile, fname);
- Rewrite(DB^.DBfile,1);
- DB^.dbname := fname;
- {$I+}
- if (IOResult = 0) and (fname <> '') then CreateDB := True
- else CreateDB := False;
- end;
-
- procedure OpenDB(VAR DB : DBFobj;fname : string);
- begin
- InitDB(DB);
- Assign(DB^.DBfile, fname);
- {$I-}
- Reset(DB^.DBfile,1);
- {$I+}
- if (IOResult = 0) and (fname <> '') then
- begin
- DB^.dbname := fname;
- DB^.readhdr;
- DB^.GotoRec(1);
- DB^._OK := TRUE;
- end else DB^._OK := FALSE;
- end;
-
- procedure DBF.NewField(FldName : string;Typ : char;Len,Dec : Byte);
- var
- count : byte;
-
- begin
- _CHGREC := True;
- inc(MaxFlds,1);
- New(dbfld[MaxFlds]);
- with dbfld[MaxFlds]^ do
- begin
- for count := 1 to length(FldName) do
- FldName[count] := UpCase(Fldname[count]);
- StrToChar(fldname,FieldName,#0);
- if typ = 'D' then len := 8;
- FieldType := Typ;
- FieldLen := Len;
- FieldDec := Dec;
- FillChar(reserved,SizeOf(reserved),#0);
- end;
- WriteHdr;
- end;
-
- procedure TrimStr(VAR InputStr : string);
- var
- count : byte;
- begin
- count := Length(InputStr);
- while (InputStr[count] = ' ') and (count > 0) do
- begin
- Delete(InputStr,count,1);
- dec(count);
- end;
- while (InputStr[1] = ' ') and (Length(InputStr) > 0) do
- Delete(InputStr,1,1);
- end;
-
- function StrToNum(Str : string) : integer;
- var
- Code,Num : integer;
- begin
- TrimStr(Str);
- Val(Str,Num,Code);
- if code > 0 then
- Num := 0;
- StrToNum := Num;
- end;
-
- procedure FillStr(VAR InputStr : string;count : byte);
- begin
- while length(InputStr) < count do
- InputStr := InputStr + ' ';
- end;
-
- procedure DBF.FRESHEN;
- begin
- rewrite(DBfile);
- writehdr;
- end;
-
- procedure DBF.deleterec(RecNum : longint);
- var
- FPos : Longint;
- begin
- GotoRec(RecNum);
- if _FOUND then
- begin
- _CHGREC := True;
- Fpos := FilePos(DBfile);
- writedbc(#42);
- Seek(DBfile,Fpos);
- end;
- end;
-
- procedure DBF.recallrec(RecNum : longint);
- var
- FPos : Longint;
- begin
- GotoRec(RecNum);
- if _FOUND then
- begin
- _CHGREC := True;
- Fpos := FilePos(DBfile);
- writedbc(#32);
- Seek(DBfile,Fpos);
- end;
- end;
-
- procedure DBF.replfld(Fnum : Byte;FStr : string);
- var
- FPos : Longint;
- code : integer;
- NewStr : String;
- count : byte;
- RealInt : Real;
- DBBuff : array[0..1000] of char;
- begin
- if _ONREC then
- begin
- _CHGREC := True;
- Fpos := FilePos(DBfile);
- Seek(DBfile,Fpos+dbfld[fnum]^.FieldAddress);
- TrimStr(Fstr);
- case dbfld[Fnum]^.FieldType of
- 'N' : begin
- Val(Fstr,RealInt,code);
- Str(RealInt:dbfld[fnum]^.FieldLen:dbfld[fnum]^.FieldDec,Fstr);
- if dbfld[fnum]^.FieldDec > 0 then
- if Pos('.',Fstr) <> dbfld[fnum]^.FieldLen-dbfld[fnum]^.FieldDec then
- FillChar(Fstr,SizeOf(Fstr),'*');
- end;
- 'D' : begin
- end;
- end;
- strtochar(Fstr,DBBuff,' ');
- blockwrite(DBfile,DBBuff,dbfld[fnum]^.FieldLen,dberr);
- Seek(DBfile,Fpos);
- end;
- end;
-
- function DBF.GetFld(Fnum : Byte) : string;
- var
- count : longint;
- TempFld : string;
- begin
- TempFld := '';
- if CurrRec > 0 then
- begin
- for count := 1 to dbfld[fnum]^.FieldLen do
- TempFld := TempFld + DBRec[count+dbfld[Fnum]^.Fieldaddress];
- Trimstr(TempFld);
- GetFld := TempFld;
- end;
- end;
-
- procedure DBF.zap;
- var
- count : longint;
- begin
- for count := 1 to dbhdr.reccount do
- deleterec(count);
- GotoRec(1);
- end;
-
- procedure DBF.recallall;
- var
- count : longint;
- begin
- for count := 1 to dbhdr.reccount do
- recallrec(count);
- GotoRec(1);
- end;
-
- procedure DBF.appendblank;
- var
- reclen : longint;
- FPos : longint;
- count : byte;
- DBBuff : array[1..4000] of char;
- begin
- _CHGREC := True;
- GotoRec(dbhdr.reccount+1);
- Fpos := FilePos(DBfile);
- reclen := 1;
- for count := 1 to MaxFlds do
- inc(reclen,dbfld[count]^.FieldLen);
- fillchar(DBBuff,SizeOf(DBBuff),#32);
- blockwrite(DBfile,DBBuff,reclen,dberr);
- writedbc(#26);
- inc(dbhdr.reccount);
- CurrRec := dbhdr.reccount;
- seek(DBfile,Fpos);
- end;
-
- function DBF.recno : longint;
- begin
- recno := round((FilePos(DBfile)-dbhdr.location)/dbhdr.recordlen)+1;
- end;
-
- function DBF.reccount : longint;
- begin
- reccount := round((FileSize(DBfile)-dbhdr.location)/dbhdr.recordlen);
- end;
-
- procedure Pause;
- var
- ch : word;
- begin
- write('Press any key to continue or ESC to exit...');
- ch := Get_Key;
- end;
-
- procedure DBF.skip;
- begin
- inc(currrec);
- gotorec(currrec);
- end;
-
- function DBF.Continue(fnum : byte;FldStr : string) : boolean;
- var
- recnum : longint;
- fns : string;
- OK : Boolean;
- begin
- OK := False;
- recnum := currrec;
- FldStr := Upper(FldStr);
- inc(recnum);
- GotoRec(recnum);
- if _FOUND then
- repeat
- fns := Upper(getfld(fnum));
- case _EXACT of
- TRUE : if fns = FldStr then OK := TRUE else inc(recnum);
- FALSE : if Pos(FldStr,fns) > 0 then OK := TRUE else inc(recnum);
- end;
- GotoRec(recnum);
- IF _FOUND = FALSE then OK := TRUE;
- until OK;
- if _FOUND = TRUE then Continue := TRUE
- else Continue := FALSE;
- end;
-
- function DBF.Locate(fnum : byte;FldStr : string) : boolean;
- var
- fns : string;
- recnum : longint;
- OK : Boolean;
- begin
- recnum := 1;
- TrimStr(FldStr);
- FldStr := Upper(FldStr);
- OK := False;
- GotoRec(recnum);
- if _FOUND then
- repeat
- fns := Upper(getfld(fnum));
- case _EXACT of
- TRUE : if fns = FldStr then OK := TRUE else inc(recnum);
- FALSE : if Pos(FldStr,fns) > 0 then OK := TRUE else inc(recnum);
- end;
- GotoRec(recnum);
- IF _FOUND = FALSE then OK := TRUE;
- until OK;
- if _FOUND = TRUE then Locate := TRUE
- else Locate := FALSE;
- end;
-
- procedure dbf.listhdr;
- var
- count : longint;
- recnum : longint;
- str : string;
- begin
- for count := 1 to MaxFlds do
- with dbfld[count]^ do
- if (FieldType = 'C') or (FieldType = 'D') then
- begin
- str := CharToStr(Fieldname);
- FillStr(str,FieldLen);
- str[0] := Chr(FieldLen);
- write(' ',str)
- end else write(' ',CharToStr(Fieldname):FieldLen);
- writeln;
- for count := 1 to MaxFlds do
- begin
- write(' ');
- with dbfld[count]^ do
- for recnum := 1 to FieldLen do
- write('-');
- end;
- end;
-
- procedure DBF.List;
- var
- count : longint;
- recnum : longint;
- str : string;
- begin
- ListHdr;
- for recnum := 1 to dbhdr.reccount do
- begin
- gotorec(recnum);
- if whereY >= 24 then
- begin
- writeln;
- pause;
- clrscr;
- ListHdr;
- end;
- writeln;
- for count := 1 to MaxFlds do
- with dbfld[count]^ do
- if (FieldType = 'C') or (FieldType = 'D') then
- begin
- str := GetFld(count);
- FillStr(str,FieldLen);
- if FieldType = 'C' then write(' ',str)
- else write(' ',dtoc(str));
- end else write(' ',GetFld(count):FieldLen);
- end;
- writeln;
- end;
-
- procedure DBF.ListDB;
- var
- recnum : longint;
- count : byte;
- ch : WORD;
- begin
- recnum := 1;
- ch := 0;
- Gotorec(1);
- while ch <> 27 do
- begin
- If _ONREC = TRUE then
- begin
- clrscr;
- GotoRec(RecNum);
- write('DATABASE: ',DBname,' Record Number ',recno,' of ',reccount,' ');
- if Deleted then writeln('DELETED')
- else writeln;
- writeln('-----------------------------------------------------');
- for count := 1 to MaxFlds do
- WriteLn(dbfld[count]^.FieldName:12,' : ',GetFld(count));
- writeln('-----------------------------------------------------');
- write('Press any key to continue or ESC to exit...');
- end;
- ch := Get_Key;
- case ch of
- _DN : if recnum < dbhdr.reccount then inc(recnum);
- _UP : if recnum > 1 then dec(recnum);
- _HOME : recnum := 1;
- _END : recnum := dbhdr.reccount;
- _F1 : deleterec(recnum);
- _F2 : recallrec(recnum);
- end;
- end;
- end;
-
- procedure DBF.CopySto(Fname : string);
- var
- TempDB : DBFobj;
- count : byte;
- TMaxDB : byte;
- begin
- TMaxDB := Max_DB;
- CreateDB(TempDB,fname);
- for count := 1 to MaxFldS do
- with dbfld[count]^ do
- TempDB^.NewField(Fieldname,FieldType,FieldLen,FieldDec);
- CloseDB(TempDB);
- Max_DB := TMaxDB;
- end;
-
- procedure DBF.pack;
- var
- TempDB,
- TempDB2 : DBFobj;
- count : byte;
- fn,fext : string;
- fname : string;
- dfile : file;
- TMaxDB : byte;
- begin
- TMaxDB := Max_DB;
- fext := '';
- if Pos('.',DBname) > 0 then
- begin
- fn := Copy(DBname,1,Pos('.',DBname)-1);
- fext := Copy(DBname,Pos('.',DBname),Length(DBname)-Pos('.',DBname)+1);
- end else fn := DBname;
- Assign(dfile,fn+'.bak');
- {$I-}
- erase(dfile);
- {$I+}
- Assign(dfile,fn+'.ba1');
- {$I-}
- erase(dfile);
- {$I+}
- CopySto(fn+'.ba1');
- OpenDB(TempDB,fn+'.ba1');
- GotoRec(1);
- while not _eof do
- begin
- if not deleted then
- begin
- TempDB^.AppendBlank;
- for count := 1 to MaxFlds do
- TempDB^.replfld(count,GetFld(count));
- end;
- skip;
- end;
- CloseDB(TempDB);
- Close(dbfile);
- Assign(dfile,fn+fext);
- {$I-}
- rename(dfile,fn+'.bak');
- {$I+}
- Assign(dfile,fn+'.ba1');
- {$I-}
- rename(dfile,fn+'.dbf');
- Assign(dbfile,fn+fext);
- Reset(dbfile);
- {$I+}
- ReadHdr;
- Max_DB := TMaxDB;
- end;
-
-
- procedure dbf.DoBrowseX(Title,BoxDef : string;TopX,TopY,BotX,BotY,Shadow,Border,WindC,HighBar : byte);
- var
- TempStr : array[1..20] of string;
- tstr : string;
- returnval,recnum : integer;
- x,y,count,Size,DispRecs,int,NumFlds,oldattr : byte;
- tp : char;
- OLDX,OLDY : BYTE;
- scrn : array[1..2000] of word;
-
- procedure DispFlds;
- var
- count,int : byte;
- oldattr : byte;
- begin
- oldattr := textattr;
- x := TopX+1;
- Y := TopY+1;
- textattr := windc;
- for count := 1 to NumFlds do
- begin
- tstr := dbfld[count]^.FieldName;
- for int := 1 to (dbfld[count]^.FieldLen-Length(tstr)) do
- tstr := tstr+' ';
- tstr := Copy(tstr,1,dbfld[count]^.FieldLen);
- writeXY(x,y,tstr);
- if WhereX < BotX then write('│');
- for int := 1 to dbfld[count]^.FieldLen do
- writeXY(x+int-1,y+1,'─');
- x := x + dbfld[count]^.FieldLen+1;
- end;
- textattr := oldattr;
- end;
-
- procedure DispSingleRec(var x,y,textc : byte;Readflds : boolean);
- var
- Count,Len,FldNumbr : byte;
- Tstr,Pix : string;
- begin
- SetUp_Field($0E,textc,windc,$00,' ',TRUE,TRUE,_Confirm,TRUE,False,false);
- for count := 1 to NumFlds do
- begin
- TempStr[count] := GetFld(count);
- if dbfld[count]^.FieldDec < 10 then Str(dbfld[count]^.FieldDec:1,Tstr)
- else Str(dbfld[count]^.FieldDec:2,Tstr);
- Len := dbfld[count]^.FieldLen;
- if dbfld[count]^.fieldtype = 'D' then
- TempStr[count] := dtoc(TempStr[count]);
- case dbfld[count]^.fieldtype of
- 'C' : Pix := '';
- 'N' : Pix := '@9:'+Tstr;
- 'D' : Pix := '@D';
- end;
- Field_Str(x,y,Len,'',TempStr[count],Pix);
- x := x + Len+1;
- if x-1 < BotX then writexy(x-1,y,'│');
- end;
- if readflds then Do_Fields(ReturnVal)
- else Release_Fields;
- end;
-
- procedure DispAllRecs;
- var
- recNum : Byte;
- begin
- x := TopX+1;
- y := TopY+2;
- for recnum := 1 to reccount do
- if recnum <= DispRecs then begin
- x := TopX+1;
- y := y + 1;
- GotoRec(RecNum);
- DispSingleRec(x,y,windc,FALSE);
- end;
- end;
-
- procedure CheckKeys(Var x,y : byte);
- begin
- case ReturnVal of
- _UP : begin
- if recnum > 1 then
- begin
- dec(recnum);
- if Y = TopY+3 then
- Scroll('D',1,$30,TopX+1,TopY+3,BotX-1,BotY-1)
- else Y := Y - 1;
- end;
- end;
- _DN : begin
- if recnum < reccount then
- begin
- inc(recnum);
- if Y < BotY-1 then Y := Y + 1
- else begin
- Scroll('U',1,$30,TopX+1,TopY+3,BotX-1,BotY-1);
- end;
- end;
- end;
- end;
- end;
-
- begin
- if reccount > 0 then
- begin
- oldx := WhereX;
- oldy := WhereY;
- if shadow > 0 then begin
- dec(BotX,2);
- dec(BotY,1);
- end;
- if (_BOF) or (_EOF) then GotoRec(1);
- Field_Id := 1;
- oldattr := textattr;
- NumFlds := MaxFlds;
- if BotX-TopX-2-(NumFlds-1) < dbhdr.recordlen+(NumFlds-1) then
- begin
- count := 0;
- NumFlds := 0;
- while count < BotX-TopX do
- begin
- inc(NumFlds);
- count := count + 1 + dbfld[NumFlds]^.FieldLen;
- end;
- BotX := count - 1 - dbfld[NumFlds]^.FieldLen + TopX;
- dec(NumFlds);
- end else BotX := dbhdr.recordlen+TopX-1+NumFlds;
- if Shadow > 0 then GetText(TopX,TopY,BotX+2,BotY+1,scrn)
- else GetText(TopX,TopY,BotX,BotY,scrn);
- if NumFlds > 0 then
- begin
- DrawBox('',Single,TopX,TopY,BotX,BotY,Shadow,Border,WindC);
- SetUp_Field($0E,windc,windc,$00,' ',TRUE,TRUE,_Confirm,TRUE,False,false);
- size := BotY-TopY;
- DispRecs := Size - 3;
- textattr := WindC;
- for count := 1 to BotX-TopX-2 do
- writexy(count+TopX,TopY+size,'░');
- writexy(BotX-1,TopY+size,'');
- writexy(TopX+1,TopY+size,Chr(017));
- textattr := $30;
- DispFlds;
- DispAllrecs;
- recnum := 1;
- Y := TopY+3;
- gotorec(recnum);
- repeat
- GotoRec(recnum);
- X := TopX+1;
- textattr := Border;
- gotoxy(x,TopY);
- Str(recnum,Tstr);
- write(trim_str(tstr),'/');
- Str(reccount,Tstr);
- write(Trim_Str(Tstr),'─────');
- if BotX-TopX > 20 then
- gotoxy(BotX-6,TopY); write(memavail);
- textattr := Windc;
- DispSingleRec(x,y,highbar,TRUE);
- for count := 1 to NumFlds do
- if dbfld[count]^.fieldtype = 'D' then ReplFld(count,ctod(TempStr[count]))
- else ReplFld(count,TempStr[count]);
- CheckKeys(x,y);
- until ReturnVal = _ESC;
- GotoRec(1);
- end;
- if Shadow > 0 then PutText(TopX,TopY,BotX+2,BotY+1,scrn)
- else PutText(TopX,TopY,BotX,BotY,scrn);
- textattr := OldAttr;
- Gotoxy(oldx,Oldy);
- end;
- end;
-
- procedure dbf.DoBrowse(X,Y: byte);
- var
- ylen : byte;
- begin
- if reccount > 0 then
- begin
- if reccount > (21-Y) then ylen := 20
- else ylen := reccount+y-1;
- dobrowseX('',single,X,Y,80,ylen+4,$00,$1f,$1f,$70);
- end;
- end;
-
- procedure DBF.SayXY(xpos,ypos,fldnum : byte);
- begin
- WriteXY(Xpos,Ypos,GetFld(fldnum));
- end;
-
- procedure DBF.GetXY(xpos,ypos,fldnum : byte;SayStr,Pix : string);
- var
- Tstr : string;
- begin
- if not _eof then
- begin
- inc(Max_Getf);
- with setcolor[1] do
- SetUp_Field(Prompt,Active,Inactive,Shadow,Clear_Chr,EscKey,
- Clean,_Confirm,Bell,UpDn,Wndw);
- inc(DB_GetF);
- New(DB_Fstr[DB_GetF]);
- DB_Fstr[DB_GetF]^.Fnum := FldNum;
- DB_Fstr[DB_GetF]^.Fstr := GetFld(FldNum);
- Get_Rd[Max_Getf] := DBarea;
-
- if dbfld[DB_GetF]^.FieldDec < 10 then Str(dbfld[DB_GetF]^.FieldDec:1,Tstr)
- else Str(dbfld[DB_GetF]^.FieldDec:2,Tstr);
- case dbfld[DB_GetF]^.fieldtype of
- 'N' : Pix := '@9:'+Tstr;
- 'D' : begin
- Pix := '@D';
- DB_Fstr[DB_GetF]^.Fstr := dtoc(DB_Fstr[DB_GetF]^.Fstr);
- end;
- end;
- Field_Str(xpos,ypos,dbfld[DB_GetF]^.FieldLen,SayStr,DB_Fstr[DB_GetF]^.Fstr,Pix);
- end;
- end;
-
- procedure PutRead;
- var
- x,count : byte;
- begin
- x := 1;
- while Get_RD[x] > 0 do
- with SelectDB[Get_RD[x]]^ do
- begin
- for count := 1 to DB_GetF do
- begin
- if dbfld[count]^.fieldtype = 'D' then
- ReplFld(DB_Fstr[count]^.Fnum,CTOD(DB_Fstr[count]^.Fstr))
- else ReplFld(DB_Fstr[count]^.Fnum,DB_Fstr[count]^.Fstr);
- release(DB_Fstr[count]);
- end;
- DB_GetF := 0;
- inc(x);
- end;
- end;
-
- procedure ReadGet;
- var
- ReturnVal : Integer;
- begin
- Do_Fields(ReturnVal);
- PutRead;
- Max_GetF := 0;
- FillChar(Get_RD,Sizeof(Get_Rd),0);
- end;
-
- begin
- Max_DB := 0;
- Max_GetF := 0;
- FillChar(Get_RD,Sizeof(Get_Rd),0);
- SetColor[1].prompt := $1f;
- SetColor[1].active := $30;
- SetColor[1].inactive := $1f;
- SetColor[1].shadow := $00;
- SetColor[1].clear_chr := ' ';
- SetColor[1].esckey := true;
- SetColor[1].clean := true;
- SetColor[1].confirm := true;
- SetColor[1].bell := true;
- SetColor[1].updn := true;
- SetColor[1].wndw := true;
- end.